Cream of the Crop 26/Cream of the Crop 26.iso/program/fpkpas92.zip/SRCRTL.ZIP/RTL/DOS/SYSTEM.INC

Text File | 1997-07-01 | 51KB | 1,908 lines

{****************************************************************************

                       Copyright (c) 1993,97 by
                    Florian Klaempfl & Michael Spiegel

 ****************************************************************************}


{ betriebssystemunabhaengige Implementationen der Unit System }

    {$I SET.INC}

    type
       textbuf = array[0..127] of char;

       textrec = record
          handle : word;
          mode : word;
          bufsize : word;
          { private : word; PRIVATE is a key word }
          { lets use that field for typed file    }
          _private : word;
          bufpos : word;
          bufend : word;
          bufptr : ^textbuf;
          openfunc : pointer;
          inoutfunc : pointer;
          flushfunc : pointer;
          closefunc : pointer;
          userdata : array[1..16] of byte;
{$ifdef linux}
          name : string[255];
{$else}
          name : string[79];
{$endif}
          buffer : textbuf;
       end;

    { don't call this routines direct }

    procedure help_constructor;

      begin
         asm
.globl HELP_CONSTRUCTOR_NE
HELP_CONSTRUCTOR_NE:
.globl HELP_CONSTRUCTOR
HELP_CONSTRUCTOR:
            { Einsprung ohne Prolog, da wir ESP vom Constructor brauchen }
            { Stack (relativ zu %ebp):
                12 Self
                8 VMT-Adresse
                4 Hauptprogramm-Addr
                0 %ebp
            }
            { Self initialisieren? }
            orl %esi,%esi
            jne LHC_4
            { Speicher anfordern, aber erst Register retten }
            { Hilfsvariable }
            subl $4,%esp
            movl %esp,%esi
            { Register retten }
            pushal
            { Speichergröße }
            movl 8(%ebp),%eax
            pushl (%eax)
            pushl %esi
            call GETMEM
            popal
            { Speicherbereich nach %esi }
            movl (%esi),%esi
            addl $4,%esp
            { falls kein Speicher vorhanden fail() }
            orl %esi,%esi
            jz LHC_5
            { set zero inside the object }
            pushal
            pushw $0
            movl 8(%ebp),%eax
            pushl (%eax)
            pushl %esi
            {                }
            call L_FILL_OBJECT
            popal
            { init self for the constructor }
            movl %esi,12(%ebp)
         LHC_4:
            { is there a VMT address ? }
            movl 8(%ebp),%eax
            orl %eax,%eax
            jnz LHC_7
            { falls der Konstruktor nichts macht, darf das Zero-Flag }
            { nicht gesetzt sein, da sonst fail() "aufgerufen" wird }
            incl %eax
            ret
         LHC_7:
            movl %eax,(%esi)
         LHC_5:
            ret
         end;
      end;

    procedure help_fail;

      begin
         asm
         end;
      end;

    procedure help_destructor;

      begin
         asm
            { Stack (relativ zu %ebp):
                12 Self
                8 VMT-Adresse
                4 Hauptprogramm-Addr
                0 %ebp
            }
.globl HELP_DESTRUCTOR_NE
HELP_DESTRUCTOR_NE:
.globl HELP_DESTRUCTOR
HELP_DESTRUCTOR:
            { temporäre Variable }
            subl $4,%esp
            movl %esp,%edi
            pushal
            { muß das Objekt gelöscht werden ? }
            movl 8(%ebp),%eax
            orl %eax,%eax
            jz LHD_3
            { ja, dann Größe aus SELF! laden }
            movl 12(%ebp),%eax
            { VMT-Zeiger (aus Self) nach %ebx }
            movl (%eax),%ebx
            { und Größe auf den Stack }
            pushl (%ebx)
            { SELF }
            movl %eax,(%edi)
            pushl %edi
            call FREEMEM
         LHD_3:
            popal
            addl $4,%esp
            ret
         end;
      end;

    procedure dump_stack(bp : longint);

    function get_next_frame(bp : longint) : longint;

      begin
         asm
         movl bp,%eax
         movl (%eax),%eax
         movl %eax,__RESULT
         end ['EAX'];
      end;

    procedure dump_frame(addr : longint);
      begin
         {to be used by symify }
         writeln('  0x',HexStr(addr,8));
      end;

      function get_addr(BP : longint) : longint;

        begin
           asm
              movl BP,%eax
              movl 4(%eax),%eax
              movl %eax,__RESULT
           end ['EAX'];
        end;
      var i, prevbp : longint;

      begin
         prevbp:=bp-1;
         i:=0;
         while bp > prevbp do
           begin
              dump_frame(get_addr(bp));
              i:=i+1;
              if i>max_frame_dump then exit;
              prevbp:=bp;
              bp:=get_next_frame(bp);
           end;
      end;

    procedure runerror(w : word);


      function get_addr : longint;

        begin
           asm
              movl (%ebp),%eax
              movl 4(%eax),%eax
              movl %eax,__RESULT
           end;
        end;

      function get_error_bp : longint;

        begin
           asm
              movl (%ebp),%eax {%ebp of run_error}
              movl %eax,__RESULT
           end ['EAX'];
        end;

      begin
         errorcode:=w;
         erroraddr:=pointer(get_addr);
         writeln('Run time error ',errorcode,' at 0x',hexstr(longint(erroraddr),8));
         dump_stack(get_error_bp);
         halt(errorcode);
      end;

    procedure io1(addr : longint);[public,alias: 'IOCHECK'];

      var
         l : longint;

      begin
         { da IOCHECK direkt aufgerufen wird und später der Optimierer }
         { vielleicht auch global Register zuweist               }
         asm
            pushal
         end;
         l:=ioresult;
         if l<>0 then
           begin
              writeln('I/O-Error ',l,' at ',addr);
              halt(1);
           end;
         asm
            popal
         end;
      end;

{$S-}
    procedure st1(stack_size : longint);[public,alias: 'STACKCHECK'];

      begin
         { called when trying to get local stack }
         { if the compiler directive $S is set   }
         asm
            movl stack_size,%ebx
            movl %esp,%eax
            subl %ebx,%eax
{$ifdef SYSTEMDEBUG}
            movl U_SYSTEM_LOWESTSTACK,%ebx
            cmpl %eax,%ebx
            jb   _is_not_lowest
            movl %eax,U_SYSTEM_LOWESTSTACK
            _is_not_lowest:
{$endif SYSTEMDEBUG}
            movl __stkbottom,%ebx
            cmpl %eax,%ebx
            jae  __short_on_stack
            leave
            ret  $4
            __short_on_stack:
         end['EAX','EBX'];
         { this needs a local variable }
         { so the function called itself !! }
         { Writeln('low in stack ');}
         RunError(202);
      end;
{no stack check in system }

    procedure re_overflow;[public,alias: 'RE_OVERFLOW'];

      var
         addr : longint;

      begin
         { write return address as overflow position }
         asm
            movl 4(%ebp),%edi
            movl %edi,addr
         end;
         writeln('integer overflow at $',hexstr(addr,8));
         writeln('Overflow at ',addr);
         halt(1);
      end;

    { kopiert Strings }
    { Darf nie direkt aufgerufen werden, da  *** nicht ***  mit }
    { einer Exceptionadresse auf dem Stack gerechnet wird }
    { außerdem werden Parameter von links nach rechts erwartet!! }
    procedure strcopy(dstr,sstr : pointer;len : longint);[public,alias: 'STRCOPY'];

      begin
         asm
            cld
            movl 16(%ebp),%edi    // Parameter laden
            movl 12(%ebp),%esi
            movl 8(%ebp),%ecx
            lodsb        // Laenge von Quelle laden
            cmpb %cl,%al
            jbe LM4
            movb %cl,%al    // wenn laenger als max. Laenge des Ziel,
                        // dann Quelle abschneiden
         LM4:
            movzbl %al,%eax
            mov %eax,%ecx
            stosb        // Länge speichern
            shrl $2,%ecx     // Erst dwordweise kopieren
            rep
            movsl
            movl %eax,%ecx     // ...und nun die restlichen Bytes
            andl $3,%ecx
            rep
            movsb
            leave        // eigenes Return, wegen anderem Stackframe
            ret $12
         end;
      end;

    { verknüpft Strings }
    { Darf nie direkt aufgerufen werden, da  *** nicht ***  mit }
    { einer Exceptionadresse auf dem Stack gerechnet wird }
    { haengt s2 an s1 an }
    { außerdem werden Parameter von links nach rechts erwartet!! }
    procedure strconcat(s1,s2 : pointer);[public,alias: 'STRCONCAT'];

      begin
         asm
        movl 12(%ebp),%edi    // Laenge des ersten Strings nach ECX
        movb (%edi),%cl
        movzbl %cl,%ecx
        movl 12(%ebp),%edi  // Startadresse fuer den zweiten String
                    // berechnen
        lea 1(%edi,%ecx),%edi
        negl %ecx        // Restplatz berechnen
        addl $0xff,%ecx
        movl 8(%ebp),%esi    // Laenge des zweiten Strings nach AL
        lodsb
            cmpb %cl,%al
            jbe LM5
            movb %cl,%al    // falls zu lang, dann abschneiden
     LM5:
        movb %al,%cl
        movl 12(%ebp),%ebx
        addb %cl,(%ebx)     // Resultatlaenge schreiben
        movzbl %cl,%ecx
            movl %ecx,%eax     // Laenge retten
            shrl $2,%ecx     // Erst dwordweise kopieren
            cld
            rep
            movsl
            movl %eax,%ecx     // ...und nun die restlichen Bytes
            andl $3,%ecx
            rep
            movsb
            leave        // eigenes Return, wegen anderem Stackframe
            ret $8
         end ['EAX','EBX','ECX','EDI'];
      end;

    { vergleicht Strings (Flags sind danach gesetzt }
    { Darf nie direkt aufgerufen werden, da  *** nicht ***  mit }
    { einer Exceptionadresse auf dem Stack gerechnet wird }
    { außerdem werden Parameter von links nach rechts erwartet!! }

    procedure strcmp(dstr,sstr : pointer);[public,alias: 'STRCMP'];

      begin
         asm
            movl 12(%ebp),%esi
            movl 8(%ebp),%edi
            cld
            lodsb        // Laenge des ersten Strings nach AL
            movb (%edi),%ah    // Laenge des zweiten Strings nach AH
            incl %edi
            movb %al,%cl    // den kuerzeren String berechnen
            cmpb %ah,%cl
            jbe LSTRCONCAT1
            movb %ah,%cl
        LSTRCONCAT1:
            orb %cl,%cl        // Laenge gleich 0 ?
            jz LSTRCONCAT2
            movzbl %cl,%ecx
            rep            // Stringvergleich
            cmpsb
            jne LSTRCONCAT3    // Ende erreicht ?
        LSTRCONCAT2:
            cmpb %ah,%al    // dann Laengenvergleich
        LSTRCONCAT3:
            leave        // eigenes Return, wegen anderem Stackframe
            ret $8
         end;
      end;

    function strpas(p : pchar) : string;

      begin
         asm
            cld
            movl 12(%ebp),%edi
            movl %edi,%esi               // Quelle
            movl $0xffffffff,%ecx        // nach Ende suchen
            xorb %al,%al
            repne
            scasb
            notl %ecx
            decl %ecx
            movl 8(%ebp),%edi          //  Ziel neu laden
            movb %cl,%al
            stosb
            rep
            movsb
         end ['ECX','EAX','ESI','EDI'];
      end;

    function strlen(p : pchar) : longint;

      begin
         asm
            cld
            movl 8(%ebp),%edi
            movl $0xffffffff,%ecx
            xorb %al,%al
            repne
            scasb
            movl $0xfffffffe,%eax
            subl %ecx,%eax
            leave
            ret $4
         end ['EDI','ECX','EAX'];
      end;

    procedure move(var source;var dest;count : longint);

      { count : EBP+16 }

      var
         sp,dp : pointer;

      { sp : EBP-4 }
      { dp : EBP-8 }

      begin
         if count=0 then
           exit;
         sp:=@source;
         dp:=@dest;
         if sp>dp then
           asm
              cld
              movl 16(%ebp),%ecx
              movl -4(%ebp),%esi
              movl -8(%ebp),%edi
              movl %ecx,%eax
              shrl $2,%ecx
              rep
              movsl
              movl %eax,%ecx
              andl $3,%ecx
              rep
              movsb
           end ['ESI','EDI','ECX','EAX']
         else if sp<dp then
           { vorsichtshalber rückwärts kopieren: }
           asm
              std
              movl 16(%ebp),%ecx
              movl -4(%ebp),%esi
              movl -8(%ebp),%edi
              addl %ecx,%esi
              addl %ecx,%edi
              movl %ecx,%eax
              andl $3,%ecx
              orl %ecx,%ecx
              jz LMOVE1
              { ESI und EDI müssen erst richtig berechnet werden }
              decl %esi
              decl %edi
              rep
              movsb
              incl %esi
              incl %edi
           LMOVE1:
              subl $4,%esi
              subl $4,%edi
              movl %eax,%ecx
              shrl $2,%ecx
              rep
              movsl
              cld
           end ['ESI','EDI','ECX'];
      end;

    procedure fillchar(var x;count : longint;value : byte);[alias: 'L_FILL_OBJECT'];

      begin
         asm
            movl 8(%ebp),%edi
            movl 12(%ebp),%ecx
            movb 16(%ebp),%dl
            // EAX mit 4fachem Byte füllen:
            movb %dl,%dh
            movw %dx,%ax
            shll $16,%eax
            movw %dx,%ax
            movl %ecx,%edx
            shrl $2,%ecx
            cld
            rep
            stosl
            movl %edx,%ecx
            andl $3,%ecx
            rep
            stosb
         end ['EAX','ECX','EDX','EDI'];
      end;

    procedure fillchar(var x;count : longint;value : char);

      begin
         fillchar(x,count,byte(value));
      end;

    procedure fillword(var x;count : longint;value : word);

      begin
         asm
            movl 8(%ebp),%edi
            movl 12(%ebp),%ecx
            movw 16(%ebp),%dx
            // EAX mit 4fachem Byte füllen:
            movw %dx,%ax
            shll $16,%eax
            movw %dx,%ax
            movl %ecx,%edx
            shrl $1,%ecx
            cld
            rep
            stosl
            movl %edx,%ecx
            andl $1,%ecx
            rep
            stosw
         end ['EAX','ECX','EDX','EDI'];
      end;

{$I INNR.INC}

    function lo(w : word) : byte;[INTERNPROC: in_lo_word];
    function hi(w : word) : byte;[INTERNPROC: in_hi_word];
    function lo(i : integer) : byte;[INTERNPROC: in_lo_word];
    function hi(i : integer) : byte;[INTERNPROC: in_hi_word];

    function lo(l : longint) : word;[INTERNPROC: in_lo_long];
    function hi(l : longint) : word;[INTERNPROC: in_hi_long];

    function ord(c : char) : byte;[INTERNPROC: in_ord_char];

    { not fast, but easy }
    function ord(b : boolean) : byte;

      begin
         ord:=byte(b);
      end;

    function chr(b : byte) : char;[INTERNPROC: in_chr_byte];

    function length(s : string) : byte;[INTERNPROC: in_length_string];

    procedure inc(var i : longint);[INTERNPROC: in_inc_dword];
    procedure inc(var i : integer);[INTERNPROC: in_inc_word];
    procedure inc(var i : word);[INTERNPROC: in_inc_word];
    procedure inc(var i : shortint);[INTERNPROC: in_inc_byte];
    procedure inc(var i : byte);[INTERNPROC: in_inc_byte];
    procedure dec(var i : longint);[INTERNPROC: in_dec_dword];
    procedure dec(var i : integer);[INTERNPROC: in_dec_word];
    procedure dec(var i : word);[INTERNPROC: in_dec_word];
    procedure dec(var i : shortint);[INTERNPROC: in_dec_byte];
    procedure dec(var i : byte);[INTERNPROC: in_dec_byte];

    procedure inc(var i : longint;a : longint);

      begin
         i:=i+a;
      end;

    procedure dec(var i : longint;a : longint);

      begin
         i:=i-a;
      end;

    procedure dec(var i : word;a : longint);

      begin
         i:=i-a;
      end;

    procedure inc(var i : word;a : longint);

      begin
         i:=i+a;
      end;

    procedure dec(var i : integer;a : longint);

      begin
         i:=i-a;
      end;

    procedure inc(var i : integer;a : longint);

      begin
         i:=i+a;
      end;

    procedure dec(var i : byte;a : longint);

      begin
         i:=i-a;
      end;

    procedure inc(var i : byte;a : longint);

      begin
         i:=i+a;
      end;

    procedure dec(var i : shortint;a : longint);

      begin
         i:=i-a;
      end;

    procedure inc(var i : shortint;a : longint);

      begin
         i:=i+a;
      end;

    function abs(l : longint) : longint;

      begin
         asm
            movl 8(%ebp),%eax
            orl %eax,%eax
            jns LMABS1
            negl %eax
         LMABS1:
            leave
            ret $4
         end ['EAX'];
      end;

    function odd(l : longint) : boolean;

      begin
        asm
           movl 8(%ebp),%eax
           andl $1,%eax
           setnz %al
           leave
           ret $4
        end ['EAX'];
      end;

    function sqr(l : longint) : longint;

      begin
         asm
            movl 8(%ebp),%eax
            imull %eax,%eax
            leave
            ret $4
         end ['EAX'];
      end;

    {$I MATH.INC}

    procedure str(l : longint;var s : string);

      var
         buffer : array[0..11] of byte;

      begin
         { Workaround: }
         if l=$80000000 then
           begin
              s:='-2147483648';
              exit;
           end;
         asm
            movl 8(%ebp),%eax        // Integer laden
            movl 12(%ebp),%edi        // Stringadresse laden
            xorl %ecx,%ecx        // Stringlaenge=0
            xorl %ebx,%ebx        // Bufferlaenge=0
            movl $0x0a,%esi        // 10 als Konstante zum Dividieren laden
            testl $0x80000000,%eax    // vorzeichenbehaftet
            jz LM2
            neg %eax
            movb $0x2d,1(%edi)      // '-' in String kopieren
            incl %ecx
         LM2:
            cdq
            idivl %esi,%eax
            addb $0x30,%dl        // Rest in ASCII umrechnen
            movb %dl,-12(%ebp,%ebx)
            incl %ebx
            cmpl $0,%eax
            jnz LM2
                            // String umkopieren
         LM3:
            movb -13(%ebp,%ebx),%al     // -13 da EBX erst spaeter
                                // dekremiert wird (spart Vergleich)
            movb %al,1(%edi,%ecx)
            incl %ecx
            decl %ebx
            jnz LM3
            movb %cl,(%edi)        // Stringlaenge kopieren
         end;
      end;

   procedure str(i : integer;var s : string);

     begin
        str(longint(i),s);
     end;

   procedure str(si : shortint;var s : string);

     begin
        str(longint(si),s);
     end;

   procedure str(b : byte;var s : string);

     begin
        str(longint(b),s);
     end;

   procedure str(w : word;var s : string);

     begin
        str(longint(w),s);
     end;

   { weder besonders genau noch schnell, aber solide und leicht verständlich }

    procedure val(const s : string;var d : double;var code : word);

      var
         { faster on a pentium }
         esign,sign : double;

         i : longint;
         exponent : longint;
         flags : byte;
         hd : double;

      begin
         d:=0;
         code:=1;
         exponent:=0;
         esign:=1;
         flags:=0;
         sign:=1;
         while (s[code]=' ') or (s[code]=#9) do
           inc(code);
         if s[code]='+' then
           inc(code)
         else if s[code]='-' then
           begin
              sign:=-1.0;
              inc(code);
           end;
         while (s[code]>='0') and (s[code]<='9') and (length(s)>=code) do
           begin
              { Vorkomma gelesen }
              flags:=flags or 1;
              d:=d*10;
              d:=d+(ord(s[code])-ord('0'));
              inc(code);
           end;
         { Kommastellen ? }
         if (s[code]='.') and (length(s)>=code) then
           begin
              hd:=0.1;
              inc(code);
              { nach einem "Komma" muß eine Ziffer folgen }
              if not((s[code]>='0') and (s[code]<='9')) or (length(s)<code) then
                begin
                   d:=0.0;
                   exit;
                end;
              while (s[code]>='0') and (s[code]<='9') and (length(s)>=code) do
                begin
                   { Nackkomma gelesen }
                   flags:=flags or 2;
                   d:=d+hd*(ord(s[code])-ord('0'));
                   hd:=hd/10.0;
                   inc(code);
                end;
           end;
         { weder Vorkomma- noch Nachkommastellen, dann abbrechen }
         if flags=0 then
           begin
              d:=0.0;
              exit;
           end;
         { Exponent ? }
         if (upcase(s[code])='E') and (length(s)>=code) then
           begin
              inc(code);
              if s[code]='+' then
                inc(code)
              else if s[code]='-' then
                begin
                   esign:=-1;
                   inc(code);
                end;
              if not((s[code]>='0') and (s[code]<='9')) or (length(s)<code) then
                begin
                   d:=0.0;
                   exit;
                end;
              while (s[code]>='0') and (s[code]<='9') and (length(s)>=code) do
                begin
                   exponent:=exponent*10;
                   exponent:=exponent+ord(s[code])-ord('0');
                   inc(code);
                end;
           end;
         { nun noch Exponent einrechnen }
         if esign>0 then
           for i:=1 to exponent do
             d:=d*10
         else
           for i:=1 to exponent do
             d:=d/10;
         { nicht alle Zeichen gelesen ? }
         if length(s)>=code then
           begin
              d:=0.0;
              exit;
           end;
         { evalute sign }
         d:=d*sign;
         { success ! }
         code:=0;
      end;

    procedure val(const s : string;var b : byte);

      var
         l : longint;

      begin
         val(s,l);
         b:=l;
      end;

    procedure val(const s : string;var b : byte;var code : word);

      var
         l : longint;

      begin
         val(s,l,code);
         b:=l;
      end;

    procedure val(const s : string;var v : longint;var code : word);

      var
         i : byte;
         u : byte;
         negativ : boolean;

      begin
         negativ := false;
         code := 1;
         u := 0;
         v := 0;
         case s[1] of
            '-' : begin
                     negativ := true;
                     code := 2;
                  end;
            '+' : code := 2;
         end;
         case s[code] of
            '$' : begin
                     i := 16;
                     inc (code);
                     while s[code] = #48 do inc (code);
                     if ord (s[0]) - code > 7 then
                        begin
                           inc (code,8);
                           exit;
                        end;
                  end;
            '%' : begin
                     i := 2;
                     inc (code);
                  end
            else i := 10;
         end;
         u := 0;
         v := 0;
         while chr (code) <= s[0] do
           begin
              case s[code] of
                 #48..#57  : u := ord (s[code]) - 48;
                 #65..#70  : u := ord (s[code]) - 55;
                 #97..#104 : u := ord (s[code]) - 87
                 else u := 16;
              end;
              if (2147483647 - v*i < u) and ((i = 10) or (i = 2)) then u := 16;
              if u >= i then
                begin
                   v := 0;
                   exit;
                end;
               v := (v*i + u);
               inc (code);
            end;
         code := 0;
         if negativ then v := 0-v;
      end;

    procedure val(const s : string;var v : longint);

     var
        code : word;

     begin
        val (s,v,code);
     end;

    {$I real2str.inc}

    procedure str(d : double;var s : string);

      begin
         str_real(-1,d,s);
      end;

    var
       randseed : longint;

    function random(l : longint) : longint;

      begin
         randseed:=randseed*134775813+1;
         random:=abs(randseed mod l);
      end;

    { don't call this direct, the call is generated by the compiler }
    procedure do_exit;[public,alias: '__EXIT'];

      begin
         while exitproc<>nil do
           begin
{$ifdef DOS}
              asm
                 movl U_SYSTEM_EXITPROC,%eax
                 call %eax
              end;
{$endif}
{$ifdef OS2}
              asm
                 movl U_SYSOS2_EXITPROC,%eax
                 call %eax
              end;
{$endif}
{$ifdef LINUX}
              asm
                 movl U_SYSLINUX_EXITPROC,%eax
                 call %eax
              end;
{$endif}
           end;
     end;

{****************************************************************************
                    subroutines for file management
 ****************************************************************************}

    type
       filerec = record
          handle : word;
          mode : word;
          recsize : word;
          _private : array[1..26] of byte;
          userdata : array[1..16] of byte;
          name : string[79];
       end;
{$IfNDef GO32V2}
    procedure doswrite(h,addr,len : longint);forward;
    function dosread(h,addr,len : longint) : longint;forward;
{$EndIf GO32V2}
    procedure fileinoutfunc(var f : textrec);

      begin
         if f.mode=fmoutput then
           begin
              doswrite(f.handle,longint(f.bufptr),f.bufpos);
           end
         else if f.mode=fminput then
           begin
              f.bufend:=dosread(f.handle,longint(f.bufptr),f.bufsize);
           end
         else halt(100);
         f.bufpos:=0;
      end;

    type
        dateifunc = procedure(var t : textrec);

    procedure fileopenfunc(var f : textrec);forward;

    procedure assign(var t : text;const s : string);

      begin
         textrec(t).handle:=$ffff;
         textrec(t).mode:=fmclosed;
         textrec(t).bufsize:=128;
         textrec(t).bufpos:=0;
         textrec(t).bufend:=0;
         textrec(t).bufptr:=@textrec(t).buffer;
         textrec(t).name:=s;
         textrec(t).openfunc:=@fileopenfunc;
      end;

    procedure assign(var f : file;const name : string);

      begin
         filerec(f).name:=name;
         filerec(f).mode:=fmclosed;
         filerec(f).handle:=$ffff;
         filerec(f).recsize:=$ffff;
      end;

{$ifdef typedfile }
    procedure assign(var f : typedfile;const name : string);

      begin
         filerec(f).name:=name;
         filerec(f).mode:=fmclosed;
         filerec(f).handle:=$ffff;
         { here we should insert the size of the type }
         { but how can we do that                     }
         filerec(f).recsize:=$ffff;
      end;
{$endif}
    procedure rewrite(var t : text);[iocheck];

      begin
         textrec(t).mode:=fmoutput;
         dateifunc(textrec(t).openfunc)(textrec(t));
      end;

    procedure reset(var t : text);[iocheck];

      begin
         textrec(t).mode:=fminput;
         dateifunc(textrec(t).openfunc)(textrec(t));
      end;

    procedure append(var t : text);[iocheck];

      begin
         textrec(t).mode:=fmappend;
         dateifunc(textrec(t).openfunc)(textrec(t));
      end;

    procedure w(len : longint;var f : textrec;var s : string);[public,alias: 'WRITE_TEXT_STRING'];

      var
         hbytes,pos,copybytes : longint;
         hs : string;

      begin
         if f.mode<>fmoutput then
           exit;
         copybytes:=length(s);

         if len>copybytes then
           begin
              hs:=space(len-copybytes);
              w(0,f,hs);
          end;
         pos:=1;
         hbytes:=f.bufsize-f.bufpos;

         { wenn überhaupt kein Platz, dann ein flush durchführen }
         if hbytes=0 then
           dateifunc(f.flushfunc)(f);

         while copybytes>hbytes do
           begin
              move(s[pos],f.buffer[f.bufpos],hbytes);
              f.bufpos:=f.bufpos+hbytes;
              dec(copybytes,hbytes);
              inc(pos,hbytes);
              dateifunc(f.inoutfunc)(f);
              hbytes:=f.bufsize-f.bufpos;
           end;
         move(s[pos],f.buffer[f.bufpos],copybytes);
         f.bufpos:=f.bufpos+copybytes;
      end;

    type
       array00 = array[0..0] of char;

    procedure w(len : longint;var f : textrec;const p : array00);[public,alias: 'WRITE_TEXT_PCHAR_AS_ARRAY'];

      var
         hbytes,pos,copybytes : longint;
         hs : string;

      begin
         if f.mode<>fmoutput then
           exit;
         copybytes:=strlen(p);
         if len>copybytes then
           begin
              hs:=space(len-copybytes);
              w(0,f,hs);
           end;
         pos:=0;
         hbytes:=f.bufsize-f.bufpos;

         { wenn überhaupt kein Platz, dann ein flush durchführen }
         if hbytes=0 then
           dateifunc(f.flushfunc)(f);

         while copybytes>hbytes do
           begin
              move(p[pos],f.buffer[f.bufpos],hbytes);
              f.bufpos:=f.bufpos+hbytes;
              dec(copybytes,hbytes);
              inc(pos,hbytes);
              dateifunc(f.inoutfunc)(f);
              hbytes:=f.bufsize-f.bufpos;
           end;
         move(p[pos],f.buffer[f.bufpos],copybytes);
         f.bufpos:=f.bufpos+copybytes;
      end;

    procedure wa(len : longint;var f : textrec;p : pchar);[public,alias: 'WRITE_TEXT_PCHAR_AS_POINTER'];

      begin
         w(len,f,p);
      end;

    procedure f1;[public,alias: 'FLUSH_STDOUT'];

      begin
         asm
            pushal
         end;
         dateifunc(textrec(output).flushfunc)(textrec(output));
         asm
            popal
         end;
      end;

    procedure flush(var t : text);[iocheck];

      begin
         if textrec(t).mode<>fmoutput then
           exit;
         dateifunc(textrec(t).flushfunc)(textrec(t));
      end;

    procedure doserase(p : pchar);forward;
    procedure dosrename(p1,p2 : pchar);forward;

    procedure erase(var t : text);[iocheck];

      var
         b : array[0..79] of char;

      begin
         if textrec(t).mode=fmclosed then
           begin
              move(textrec(t).name[1],b,length(textrec(t).name));
              b[length(textrec(t).name)]:=#0;
              doserase(b);
           end;
      end;

    procedure erase(var f : file);[iocheck];

      var
         b : array[0..79] of char;

      begin
         if filerec(f).mode=fmclosed then
           begin
              move(filerec(f).name[1],b,length(filerec(f).name));
              b[length(filerec(f).name)]:=#0;
              doserase(b);
           end;
      end;

    procedure rename(var f : file;const s : string);[iocheck];

      var
         b1,b2 : array[0..79] of char;

      begin
         if filerec(f).mode=fmclosed then
           begin
              move(filerec(f).name[1],b1,length(filerec(f).name));
              b1[length(filerec(f).name)]:=#0;
              move(s[1],b2,length(s));
              b2[length(s)]:=#0;
              dosrename(b1,b2);
              filerec(f).name:=s;
           end;
      end;

    procedure rename(var t : text;const s : string);[iocheck];

      var
         b1,b2 : array[0..79] of char;

      begin
         if textrec(t).mode=fmclosed then
           begin
              move(textrec(t).name[1],b1,length(textrec(t).name));
              b1[length(textrec(t).name)]:=#0;
              move(s[1],b2,length(s));
              b2[length(s)]:=#0;
              dosrename(b1,b2);
              textrec(t).name:=s;
           end;
      end;

    procedure w(len : longint;var t : textrec;l : longint);[public,alias: 'WRITE_TEXT_LONGINT'];

      var
         s : string;

      begin
         str(l,s);
         w(len,t,s);
      end;

    procedure w(fixkomma,len : longint;var t : textrec;r : real);[public,alias: 'WRITE_TEXT_REAL'];

      var
         s : string;

      begin
         str_real(fixkomma,r,s);
         w(len,t,s);
      end;

    { heißt wc, damit der Compiler keinen rekursiven Aufruf erzeugt }

    procedure wc(len : longint;var t : textrec;c : char);[public,alias: 'WRITE_TEXT_CHAR'];

      var
         hs : string;

      begin
         if t.mode<>fmoutput then
           exit;

         if len>1 then
           begin
              hs:=space(len-1);
              w(0,t,hs);
           end;

         if t.bufpos+1>=t.bufsize then
           dateifunc(t.flushfunc)(t);
         t.buffer[t.bufpos]:=c;
         inc(t.bufpos);
      end;

    procedure r(var f : textrec);[public,alias: 'READLN_TEXT'];

      begin
         { file must be opened for reading }
         if f.mode<>fminput then
           exit;
         { Noch Zeichen im Buffer? ansonsten laden }
         if f.bufpos>=f.bufend then
           dateifunc(f.inoutfunc)(f);
         while f.buffer[f.bufpos]<>#10 do
           begin
              { trotz Laden nichts im Buffer ? }
              if f.bufpos>=f.bufend then
                { dann vergiss' s }
                exit;
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);
           end;
         inc(f.bufpos);
      end;

    procedure r(var f : textrec;var s : string);[public,alias: 'READ_TEXT_STRING'];

      begin
         { the file must be opened for input }
         if f.mode<>fminput then
           exit;
         { delete the string }
         s:='';
         { Noch Zeichen im Buffer? ansonsten Laden }
         if f.bufpos>=f.bufend then
           dateifunc(f.inoutfunc)(f);

         while f.buffer[f.bufpos]<>#10 do
           begin
              { if no chars in the buffer, then forget this }
              if f.bufpos>=f.bufend then
                exit;
              if f.buffer[f.bufpos]<>#13 then
                s:=s+f.buffer[f.bufpos];
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);
           end;
      end;

    procedure r(var f : textrec;var l : longint);[public,alias: 'READ_TEXT_LONGINT'];

      var
         hs : string;
         code : word;

      label
         ready;

      begin
         if f.mode<>fminput then
           exit;
         { del the number }
         l:=0;
         { clear the string }
         hs:='';
         { Noch Zeichen im Buffer? ansonsten Laden }
         if f.bufpos>=f.bufend then
           dateifunc(f.inoutfunc)(f);
         { ignore spaces }
         while (f.buffer[f.bufpos]=#13) or
               (f.buffer[f.bufpos]=#10) or
               (f.buffer[f.bufpos]=#9) or
               (f.buffer[f.bufpos]=' ') do
           begin
              { if no chars in the buffer, then forget this }
              if f.bufpos>=f.bufend then
                exit;
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);
           end;
         { read the sign }
         if (f.buffer[f.bufpos]='-') or
            (f.buffer[f.bufpos]='+') then
           begin
              { if no chars in the buffer, then forget this }
              if f.bufpos>=f.bufend then
                goto ready;

              hs:=hs+f.buffer[f.bufpos];
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);
           end;
         while (ord(f.buffer[f.bufpos])>=ord('0')) and
           (ord(f.buffer[f.bufpos])<=ord('9')) do
           begin
              { if no chars in the buffer, then forget this }
              if f.bufpos>=f.bufend then
                goto ready;

              hs:=hs+f.buffer[f.bufpos];
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);
           end;
      ready:
         val(hs,l,code);
         if code<>0 then
           runerror(106);
      end;

    procedure r(var f : textrec;var l : integer);[public,alias:'READ_TEXT_INTEGER'];

      var
         v : longint;

      begin
         r(f,v);
         l:=v;
      end;

    procedure r(var f : textrec;var l : word);[public,alias:'READ_TEXT_WORD'];

      var
         v : longint;

      begin
         r(f,v);
         l:=v;
      end;

    procedure r(var f : textrec;var l : shortint);[public,alias:'READ_TEXT_SHORTINT'];

      var
         v : longint;

      begin
         r(f,v);
         l:=v;
      end;

    procedure r(var f : textrec;var l : byte);[public,alias:'READ_TEXT_BYTE'];

      var
         v : longint;

      begin
         r(f,v);
         l:=v;
      end;
    procedure r(var f : textrec;var c : char);[public,alias: 'READ_TEXT_CHAR'];

      var
         hs : string;
         code : word;

      begin
         c:=#0;

         { the file must be opened for input }
         if f.mode<>fminput then
           exit;

         { maybe reload }
         if f.bufpos>=f.bufend then
           dateifunc(f.inoutfunc)(f);

         if f.bufpos>=f.bufend then
           c:=#26
         else c:=f.buffer[f.bufpos];

         inc(f.bufpos);
      end;

    procedure r(var f : textrec;var d : double);[public,alias: 'READ_TEXT_REAL'];

      var
         hs : string;
         code : word;

      label
         ready;

      begin
         { f... long code }
         if f.mode<>fminput then
           exit;
         { del the number }
         d:=0.0;
         { clear the string }
         hs:='';

         { maybe reload }
         if f.bufpos>=f.bufend then
           dateifunc(f.inoutfunc)(f);

         { ignore spaces }
         while (f.buffer[f.bufpos]=#13) or
               (f.buffer[f.bufpos]=#10) or
               (f.buffer[f.bufpos]=#9) or
               (f.buffer[f.bufpos]=' ') do
           begin
              { if no chars in the buffer, then forget this }
              if f.bufpos>=f.bufend then
                exit;
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);
           end;

         { read the sign }
         if (f.buffer[f.bufpos]='-') or
            (f.buffer[f.bufpos]='+') then
           begin
              { if no chars in the buffer, then forget this }
              if f.bufpos>=f.bufend then
                goto ready;

              hs:=hs+f.buffer[f.bufpos];
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);
           end;
         while (ord(f.buffer[f.bufpos])>=ord('0')) and
           (ord(f.buffer[f.bufpos])<=ord('9')) do
           begin
              { if no chars in the buffer, then forget this }
              if f.bufpos>=f.bufend then
                goto ready;

              hs:=hs+f.buffer[f.bufpos];
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);
           end;
         { comma ? }
         if (f.buffer[f.bufpos]='.') then
           begin
              { if no chars in the buffer, then forget this }
              if f.bufpos>=f.bufend then
                goto ready;

              hs:=hs+'.';
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);

              while (ord(f.buffer[f.bufpos])>=ord('0')) and
                (ord(f.buffer[f.bufpos])<=ord('9')) do
                begin
                   { if no chars in the buffer, then forget this }
                   if f.bufpos>=f.bufend then
                     goto ready;

                   hs:=hs+f.buffer[f.bufpos];
                   inc(f.bufpos);
                   if f.bufpos>=f.bufend then
                     dateifunc(f.inoutfunc)(f);
                end;
           end;

         { exponent ? }
         if (upcase(f.buffer[f.bufpos])='E') then
           begin
              { if no chars in the buffer, then forget this }
              if f.bufpos>=f.bufend then
                goto ready;

              hs:=hs+'E';
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);

              { read the sign of the exponent }
              if (f.buffer[f.bufpos]='-') or
                 (f.buffer[f.bufpos]='+') then
                begin
                   { if no chars in the buffer, then forget this }
                   if f.bufpos>=f.bufend then
                     goto ready;

                   hs:=hs+f.buffer[f.bufpos];
                   inc(f.bufpos);
                   if f.bufpos>=f.bufend then
                     dateifunc(f.inoutfunc)(f);
                end;
              while (ord(f.buffer[f.bufpos])>=ord('0')) and
                (ord(f.buffer[f.bufpos])<=ord('9')) do
                begin
                   { if no chars in the buffer, then forget this }
                   if f.bufpos>=f.bufend then
                     goto ready;

                   hs:=hs+f.buffer[f.bufpos];
                   inc(f.bufpos);
                   if f.bufpos>=f.bufend then
                     dateifunc(f.inoutfunc)(f);
                end;
           end;
      ready:
         val(hs,d,code);
         if code<>0 then
           runerror(106);
      end;
{$ifndef VER0_6}
   procedure r(var f : textrec;var s : pchar);[public,alias:'READ_TEXT_PCHAR_AS_POINTER'];

      var p : pchar;

      begin
         { the file must be opened for input }
         if (f.mode<>fminput) or (s=nil) then
           exit;
         { delete the string }
         s^:=#0;
         p:=s;
         { if there are no more chars in the buffer then reload }
         if f.bufpos>=f.bufend then
           dateifunc(f.inoutfunc)(f);
         while f.buffer[f.bufpos]<>#10 do
           begin
              { if no chars in the buffer, then forget this }
              if f.bufpos>=f.bufend then
                exit;
              if f.buffer[f.bufpos]<>#13 then
                move (f.buffer[f.bufpos],p^,1);
              inc (longint(p));
              p^:=#0;
              inc(f.bufpos);
              if f.bufpos>=f.bufend then
                dateifunc(f.inoutfunc)(f);
           end;
      end;

    procedure r(var f : textrec;var fi : fixed);[public,alias: 'READ_TEXT_FIXED'];

      var
         d : double;

         begin
        r(f,d);
{        longint(fi):=trunc(65536*d); }
         end;
{$endif VER0_6}

    function ioresult : word;

      begin
         ioresult:=inoutres;
         inoutres:=0;
      end;

    procedure blockread(var f : file;var buf;count : word;var result : word);[iocheck];

      var
         rl : longint;

      begin
         blockread(f,buf,count,rl);
         result:=rl;
      end;

    procedure w(var t : textrec);[public,alias: 'WRITELN_TEXT'];

      var
         hs : string;

      begin
         hs:=#13#10;
         w(0,t,hs);
      end;

    procedure close(var t : text);[public,alias: 'CLOSE_TEXT',iocheck];

      begin
         if (textrec(t).mode<>fmclosed) then
           begin
              dateifunc(textrec(t).flushfunc)(textrec(t));
              textrec(t).mode:=fmclosed;
              dateifunc(textrec(t).closefunc)(textrec(t));
           end;
      end;

    procedure initexception;[public,alias: 'INITEXCEPTION'];

      begin
         writeln('Exception während der Programminitialisierung aufgetreten');
         halt;
      end;

    function ptr(sel,off : word) : pointer;

      begin
{$ifdef DOS}
         ptr:=pointer($e0000000+sel shl 4+off);
{$else}
         ptr:=pointer(sel shl 4+off);
{$endif}
      end;

    function eof : boolean;

      begin
         eof:=eof(input);
      end;

    function eoln(var t : text) : boolean;

      begin
         { maybe we need new data }
         if textrec(t).bufpos>=textrec(t).bufend then
           dateifunc(textrec(t).inoutfunc)(textrec(t));

         eoln:=eof or
           (textrec(t).buffer[textrec(t).bufpos]=#13) or
           (textrec(t).buffer[textrec(t).bufpos]=#10);
      end;

    function eoln : boolean;

      begin
         eoln:=eoln(input);
      end;

{****************************************************************************
                    subroutines for string handling
 ****************************************************************************}

    function copy(const s : string;index : integer;count : byte): string;

       var
          i : longint;

       begin
          if count < 0 then count := 0;
          if index <= 0 then index := 1;
          if index <= ord(s[0]) then
            begin
               if count + index > ord(s[0]) then copy[0] := chr (ord(s[0]) - index +1)
                 else copy[0] := chr (count);
               for i := 1 to ord (s[0]) do copy[i] := s [index -1 + i];
            end
          else copy[0] := #0;
       end;

    procedure delete(var s : string;index : integer;count : integer);

       var i : longint;

       begin
          if index <= 0 then
            begin
               count := count + index -1;
               index := 1;
            end;
          if count <= 0 then exit;
          if ord (s[0]) >= index then
            begin
               if count + index > ord (s[0]) then count:= ord (s[0]) -index + 1;
                 for i := 0 to ord (s[0]) - (count+index) do
                   s [i+index] := s[i+count+index];
               s[0] := chr(ord (s[0]) - count);
            end;
       end;

    procedure insert(const source : string;var s : string;index : integer);

       var s3 : string;

       begin
          if index <= 0 then index := 1;
          s3 := copy (s, index, length(s));
          if index > length (s) then index := ord(s[0]) +1;
          s[0] := chr (index - 1);
          s := s + source + s3;
       end;

    function pos(const substr : string;const s : string): byte;

       var i : longint;
           j : byte;
           e : boolean;

       begin
          i := 0;
          j := 0;
          e := true;
          if substr = '' then e := false;
          while (e) and (i <= length (s) - length (substr)) do
            begin
               inc (i);
               if substr = copy (s,i,length (substr)) then
                 begin
                    j := i;
                    e := false;
                 end;
            end;
          pos := j;
       end;

    function upcase(c : char) : char;

       begin
          if (c >= #97) and (c <= #122) then c := chr(ord (c) - 32)
          else if (c >= #128) and (c <= #165) then
            case c of
                 #129 : c := #154;  {D}
                 #132 : c := #142;  {D}
                 #148 : c := #153;  {D}
                 #130 : c := #144;  {F}
                 #135 : c := #128;  {F}
                 #134 : c := #143;  {E}
                 #164 : c := #165;  {E}
            end;
          upcase := c;
       end;

    function upcase(const s : string) : string;

       var i : longint;

       begin
          upcase[0]:=s[0];
          for i := 1 to length (s) do
            upcase[i] := upcase (s[i]);
       end;

    function lowercase(c : char) : char;

       begin
          if (c >= #65) and (c <= #90) then c := chr(ord (c) + 32)
          else if (c >= #128) and (c <= #165) then
            case c of
                 #154 : c := #129;  {D}
                 #142 : c := #132;  {D}
                 #153 : c := #148;  {D}
                 #144 : c := #130;  {F}
                 #128 : c := #135;  {F}
                 #143 : c := #134;  {E}
                 #165 : c := #164;  {E}
            end;
          lowercase := c;
       end;

    function lowercase(const s : string) : string;

      var i : longint;

      begin
         lowercase [0] := s[0];
         for i := 1 to length (s) do
           lowercase[i] := lowercase (s[i]);
      end;

    function space (b : byte): string;

       var i : longint;

       begin
          space[0] := chr(b);
          for i := 1 to b do space[i] := #32;
       end;

    function hexstr(val : longint;cnt : byte) : string;

      const
         hexval : string[16]=('0123456789ABCDEF');

      var
         s : string;
         l2,i : integer;
         l1 : longInt;

      begin
         s[0]:=char(cnt);
         l1:=longint($f) shl (4*(cnt-1));
         for i:=1 to cnt do
           begin
              l2:=(val and l1) shr (4*(cnt-i));
              l1:=l1 shr 4;
              s[i]:=hexval[l2+1];
           end;
         hexstr:=s;
      end;

    function binstr(val : longint;cnt : byte) : string;

      var
         s : string;
         mask,i : word;

      begin
         s[0]:=char(cnt);
         mask:=word(1) shl (cnt-1);
         for i:=1 to cnt do
           begin
              if (val and mask)<>0 then
                s[i]:='1' else s[i]:='0';
              mask:=mask shr 1;
           end;
         binstr:=s;
      end;

{ old version doesn't like this }
{$ifdef dummy}
{$ifndef VER0_6_5}
{$ifndef VER0_6_4}
    constructor tobject.create;

      begin
      end;

    destructor tobject.free;

      begin
      end;

{$endif}
{$endif}
{$endif}